home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / xselect.c < prev   
Encoding:
C/C++ Source or Header  |  1995-08-09  |  64.1 KB  |  2,062 lines
  1. /* X Selection processing for XEmacs
  2.    Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation.
  3.  
  4. This file is part of XEmacs.
  5.  
  6. XEmacs is free software; you can redistribute it and/or modify it
  7. under the terms of the GNU General Public License as published by the
  8. Free Software Foundation; either version 2, or (at your option) any
  9. later version.
  10.  
  11. XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14. for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with XEmacs; see the file COPYING.  If not, write to the Free
  18. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* Synched up with: Not synched with FSF. */
  21.  
  22. /* Rewritten by jwz */
  23.  
  24. #include <config.h>
  25. #include "lisp.h"
  26.  
  27. #include "device-x.h"
  28. #include "frame-x.h"    /* Need this to get the X window of selected_frame */
  29. #include "objects-x.h"
  30.  
  31. #include "opaque.h"
  32. #include "systime.h"
  33.  
  34. #ifdef LWLIB_USES_MOTIF
  35. # define MOTIF_CLIPBOARDS
  36. #endif
  37.  
  38. #ifdef MOTIF_CLIPBOARDS
  39. # include <Xm/CutPaste.h>
  40. static void hack_motif_clipboard_selection (Atom selection_atom,
  41.                         Lisp_Object selection_value,
  42.                         Time time,Display *display,
  43.                         Window selecting_window,
  44.                         Bool owned_p);
  45. #endif
  46.  
  47. #define CUT_BUFFER_SUPPORT
  48.  
  49. Lisp_Object QPRIMARY, QSECONDARY, QSTRING, QINTEGER, QCLIPBOARD, QTIMESTAMP,
  50.   QTEXT, QDELETE, QMULTIPLE, QINCR, QEMACS_TMP, QTARGETS, QATOM, QNULL,
  51.   QATOM_PAIR;
  52.  
  53. #ifdef EPOCH
  54. Lisp_Object QARC, QBITMAP, QCARDINAL, QCURSOR, QDRAWABLE, QFONT, QINTEGER,
  55.   QPIXMAP, QPOINT, QRECTANGLE, QWINDOW, QWM_HINTS, QWM_SIZE_HINTS;
  56. #endif /* EPOCH */
  57.  
  58. #ifdef CUT_BUFFER_SUPPORT
  59. Lisp_Object QCUT_BUFFER0, QCUT_BUFFER1, QCUT_BUFFER2, QCUT_BUFFER3,
  60.   QCUT_BUFFER4, QCUT_BUFFER5, QCUT_BUFFER6, QCUT_BUFFER7;
  61. #endif
  62.  
  63. Lisp_Object Vx_lost_selection_hooks;
  64. Lisp_Object Vx_sent_selection_hooks;
  65.  
  66. /* If this is a smaller number than the max-request-size of the display,
  67.    emacs will use INCR selection transfer when the selection is larger
  68.    than this.  The max-request-size is usually around 64k, so if you want
  69.    emacs to use incremental selection transfers when the selection is 
  70.    smaller than that, set this.  I added this mostly for debugging the
  71.    incremental transfer stuff, but it might improve server performance.
  72.  */
  73. #define MAX_SELECTION_QUANTUM 0xFFFFFF
  74.  
  75. #define SELECTION_QUANTUM(dpy) ((XMaxRequestSize (dpy) << 2) - 100)
  76.  
  77. /* This is an association list whose elements are of the form
  78.      ( selection-name selection-value selection-timestamp )
  79.    selection-name is a lisp symbol, whose name is the name of an X Atom.
  80.    selection-value is the value that emacs owns for that selection.
  81.      It may be any kind of Lisp object.
  82.    selection-timestamp is the time at which emacs began owning this selection,
  83.      as a cons of two 16-bit numbers (making a 32 bit time).
  84.    If there is an entry in this alist, then it can be assumed that emacs owns
  85.     that selection.
  86.    The only (eq) parts of this list that are visible from elisp are the
  87.     selection-values.
  88.  */
  89. Lisp_Object Vselection_alist;
  90.  
  91. /* This is an alist whose CARs are selection-types (whose names are the same
  92.    as the names of X Atoms) and whose CDRs are the names of Lisp functions to
  93.    call to convert the given Emacs selection value to a string representing 
  94.    the given selection type.  This is for elisp-level extension of the emacs
  95.    selection handling.
  96.  */
  97. Lisp_Object Vselection_converter_alist;
  98.  
  99. /* If the selection owner takes too long to reply to a selection request,
  100.    we give up on it.  This is in seconds (0 = no timeout).
  101.  */
  102. int x_selection_timeout;
  103.  
  104.  
  105. /* Utility functions */
  106.  
  107. static void lisp_data_to_selection_data (struct device *,
  108.                      Lisp_Object obj,
  109.                      unsigned char **data_ret,
  110.                      Atom *type_ret,
  111.                      unsigned int *size_ret,
  112.                      int *format_ret);
  113. static Lisp_Object selection_data_to_lisp_data (struct device *,
  114.                         unsigned char *data,
  115.                         int size,
  116.                         Atom type,
  117.                         int format);
  118. static Lisp_Object x_get_window_property_as_lisp_data (Display *,
  119.                                Window,
  120.                                Atom property,
  121.                                Lisp_Object target_type,
  122.                                Atom selection_atom);
  123.  
  124. static int expect_property_change (Display *, Window, Atom prop, int state);
  125. static void wait_for_property_change (long);
  126. static void unexpect_property_change (int);
  127. static int waiting_for_other_props_on_window (Display *, Window);
  128.  
  129. /* This converts a Lisp symbol to a server Atom, avoiding a server 
  130.    roundtrip whenever possible.
  131.  */
  132. static Atom
  133. symbol_to_x_atom (struct device *d, Lisp_Object sym)
  134. {
  135.   Display *display = DEVICE_X_DISPLAY (d);
  136.   Atom val;
  137.   if (NILP (sym))        return XA_PRIMARY;
  138.   if (EQ (sym, Qt))        return XA_SECONDARY;
  139.   if (EQ (sym, QPRIMARY))   return XA_PRIMARY;
  140.   if (EQ (sym, QSECONDARY)) return XA_SECONDARY;
  141.   if (EQ (sym, QSTRING))    return XA_STRING;
  142.   if (EQ (sym, QINTEGER))   return XA_INTEGER;
  143.   if (EQ (sym, QATOM))        return XA_ATOM;
  144.   if (EQ (sym, QCLIPBOARD)) return DEVICE_XATOM_CLIPBOARD (d);
  145.   if (EQ (sym, QTIMESTAMP)) return DEVICE_XATOM_TIMESTAMP (d);
  146.   if (EQ (sym, QTEXT))        return DEVICE_XATOM_TEXT (d);
  147.   if (EQ (sym, QDELETE))    return DEVICE_XATOM_DELETE (d);
  148.   if (EQ (sym, QMULTIPLE))  return DEVICE_XATOM_MULTIPLE (d);
  149.   if (EQ (sym, QINCR))        return DEVICE_XATOM_INCR (d);
  150.   if (EQ (sym, QEMACS_TMP)) return DEVICE_XATOM_EMACS_TMP (d);
  151.   if (EQ (sym, QTARGETS))   return DEVICE_XATOM_TARGETS (d);
  152.   if (EQ (sym, QNULL))        return DEVICE_XATOM_NULL (d);
  153. #ifdef EPOCH
  154.   if (EQ (sym, QARC))       return XA_ARC;
  155.   if (EQ (sym, QBITMAP))    return XA_BITMAP;
  156.   if (EQ (sym, QCARDINAL))  return XA_CARDINAL;
  157.   if (EQ (sym, QCURSOR))    return XA_CURSOR;
  158.   if (EQ (sym, QDRAWABLE))  return XA_DRAWABLE;
  159.   if (EQ (sym, QFONT))      return XA_FONT;
  160.   if (EQ (sym, QINTEGER))   return XA_INTEGER;
  161.   if (EQ (sym, QPIXMAP))    return XA_PIXMAP;
  162.   if (EQ (sym, QPOINT))     return XA_POINT;
  163.   if (EQ (sym, QRECTANGLE)) return XA_RECTANGLE;
  164.   if (EQ (sym, QWINDOW))    return XA_WINDOW;
  165.   if (EQ (sym, QWM_HINTS))  return XA_WM_HINTS;
  166.   if (EQ (sym, QWM_SIZE_HINTS)) return XA_WM_SIZE_HINTS;
  167. #endif /* EPOCH */
  168.  
  169. #ifdef CUT_BUFFER_SUPPORT
  170.   if (EQ (sym, QCUT_BUFFER0)) return XA_CUT_BUFFER0;
  171.   if (EQ (sym, QCUT_BUFFER1)) return XA_CUT_BUFFER1;
  172.   if (EQ (sym, QCUT_BUFFER2)) return XA_CUT_BUFFER2;
  173.   if (EQ (sym, QCUT_BUFFER3)) return XA_CUT_BUFFER3;
  174.   if (EQ (sym, QCUT_BUFFER4)) return XA_CUT_BUFFER4;
  175.   if (EQ (sym, QCUT_BUFFER5)) return XA_CUT_BUFFER5;
  176.   if (EQ (sym, QCUT_BUFFER6)) return XA_CUT_BUFFER6;
  177.   if (EQ (sym, QCUT_BUFFER7)) return XA_CUT_BUFFER7;
  178. #endif
  179.   if (!SYMBOLP (sym)) abort ();
  180.  
  181.   val = XInternAtom (display, string_ext_data (XSYMBOL (sym)->name), False);
  182.   return val;
  183. }
  184.  
  185.  
  186. /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
  187.    and calls to intern whenever possible.
  188.  */
  189. Lisp_Object
  190. x_atom_to_symbol (struct device *d, Atom atom)
  191. {
  192.   char *str;
  193.   Lisp_Object val;
  194.   Display *display = DEVICE_X_DISPLAY (d);
  195.   if (! atom) return Qnil;
  196.   if (atom == XA_PRIMARY)      return QPRIMARY;
  197.   if (atom == XA_SECONDARY)    return QSECONDARY;
  198.   if (atom == XA_STRING)       return QSTRING;
  199.   if (atom == XA_INTEGER)      return QINTEGER;
  200.   if (atom == XA_ATOM)           return QATOM;
  201.   if (atom == DEVICE_XATOM_CLIPBOARD (d)) return QCLIPBOARD;
  202.   if (atom == DEVICE_XATOM_TIMESTAMP (d)) return QTIMESTAMP;
  203.   if (atom == DEVICE_XATOM_TEXT (d))      return QTEXT;
  204.   if (atom == DEVICE_XATOM_DELETE (d))    return QDELETE;
  205.   if (atom == DEVICE_XATOM_MULTIPLE (d))  return QMULTIPLE;
  206.   if (atom == DEVICE_XATOM_INCR (d))      return QINCR;
  207.   if (atom == DEVICE_XATOM_EMACS_TMP (d)) return QEMACS_TMP;
  208.   if (atom == DEVICE_XATOM_TARGETS (d))   return QTARGETS;
  209.   if (atom == DEVICE_XATOM_NULL (d))      return QNULL;
  210. #ifdef EPOCH
  211.   if (atom == XA_ARC)          return QARC;
  212.   if (atom == XA_BITMAP)       return QBITMAP;
  213.   if (atom == XA_CARDINAL)     return QCARDINAL;
  214.   if (atom == XA_CURSOR)       return QCURSOR;
  215.   if (atom == XA_DRAWABLE)     return QDRAWABLE;
  216.   if (atom == XA_FONT)         return QFONT;
  217.   if (atom == XA_INTEGER)      return QINTEGER;
  218.   if (atom == XA_PIXMAP)       return QPIXMAP;
  219.   if (atom == XA_POINT)        return QPOINT;
  220.   if (atom == XA_RECTANGLE)    return QRECTANGLE;
  221.   if (atom == XA_WINDOW)       return QWINDOW;
  222.   if (atom == XA_WM_HINTS)     return QWM_HINTS;
  223.   if (atom == XA_WM_SIZE_HINTS) return QWM_SIZE_HINTS;
  224. #endif /* EPOCH */
  225. #ifdef CUT_BUFFER_SUPPORT
  226.   if (atom == XA_CUT_BUFFER0) return QCUT_BUFFER0;
  227.   if (atom == XA_CUT_BUFFER1) return QCUT_BUFFER1;
  228.   if (atom == XA_CUT_BUFFER2) return QCUT_BUFFER2;
  229.   if (atom == XA_CUT_BUFFER3) return QCUT_BUFFER3;
  230.   if (atom == XA_CUT_BUFFER4) return QCUT_BUFFER4;
  231.   if (atom == XA_CUT_BUFFER5) return QCUT_BUFFER5;
  232.   if (atom == XA_CUT_BUFFER6) return QCUT_BUFFER6;
  233.   if (atom == XA_CUT_BUFFER7) return QCUT_BUFFER7;
  234. #endif
  235.  
  236.   str = XGetAtomName (display, atom);
  237.   if (! str) return Qnil;
  238.   val = intern (str);
  239.   XFree (str);
  240.   return val;
  241. }
  242.  
  243.  
  244. /* Do protocol to assert ourself as a selection owner.
  245.    Update the Vselection_alist so that we can reply to later requests for 
  246.    our selection.
  247.  */
  248. static void
  249. x_own_selection (Lisp_Object selection_name, Lisp_Object selection_value)
  250. {
  251.   struct device *d = get_x_device (Qnil);
  252.   Display *display = DEVICE_X_DISPLAY (d);
  253.   struct frame *sel_frame = selected_frame ();
  254.   Window selecting_window = XtWindow (FRAME_X_TEXT_WIDGET (sel_frame));
  255.   /* Use the time of the last-read mouse or keyboard event. 
  256.      For selection purposes, we use this as a sleazy way of knowing what the
  257.      current time is in server-time.  This assumes that the most recently read
  258.      mouse or keyboard event has something to do with the assertion of the
  259.      selection, which is probably true.
  260.      */
  261.   Time time = DEVICE_X_MOUSE_TIMESTAMP (d);
  262.   Atom selection_atom;
  263.  
  264.   CHECK_SYMBOL (selection_name, 0);
  265.   selection_atom = symbol_to_x_atom (d, selection_name);
  266.  
  267.   XSetSelectionOwner (display, selection_atom, selecting_window, time);
  268.  
  269.   /* Now update the local cache */
  270.   {
  271.     /* We do NOT use time_to_lisp() here any more, like we used to.
  272.        That assumed equivalence of time_t and Time, which is not
  273.        necessarily the case (e.g. under OSF on the Alphas, where
  274.        Time is a 64-bit quantity and time_t is a 32-bit quantity).
  275.  
  276.        Opaque pointers are the clean way to go here.
  277.      */
  278.     Lisp_Object selection_time = make_opaque (sizeof (time), &time);
  279.     Lisp_Object selection_data = Fcons (selection_name,
  280.                     Fcons (selection_value,
  281.                            Fcons (selection_time, Qnil)));
  282.     Lisp_Object prev_value = assq_no_quit (selection_name, Vselection_alist);
  283.     Vselection_alist = Fcons (selection_data, Vselection_alist);
  284.  
  285.     /* If we already owned the selection, remove the old selection data.
  286.        Perhaps we should destructively modify it instead.
  287.        Don't use Fdelq() as that may QUIT;.
  288.      */
  289.     if (!NILP (prev_value))
  290.       {
  291.     Lisp_Object rest;    /* we know it's not the CAR, so it's easy. */
  292.     for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
  293.       if (EQ (prev_value, Fcar (XCDR (rest))))
  294.         {
  295.           XCDR (rest) = Fcdr (XCDR (rest));
  296.           break;
  297.         }
  298.       }
  299. #ifdef MOTIF_CLIPBOARDS
  300.     hack_motif_clipboard_selection (selection_atom, selection_value,
  301.                     time, display, selecting_window,
  302.                     !NILP (prev_value));
  303. #endif
  304.   }
  305. }
  306.  
  307.  
  308. #ifdef MOTIF_CLIPBOARDS /* Bend over baby.  Take it and like it. */
  309.  
  310. # ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
  311. static void motif_clipboard_cb ();
  312. # endif
  313.  
  314. static void
  315. hack_motif_clipboard_selection (Atom selection_atom,
  316.                 Lisp_Object selection_value,
  317.                 Time time,
  318.                 Display *display,
  319.                 Window selecting_window,
  320.                 Bool owned_p)
  321. {
  322.   struct device *d = get_device_from_display (display);
  323.   /* Those Motif wankers can't be bothered to follow the ICCCM, and do
  324.      their own non-Xlib non-Xt clipboard processing.  So we have to do
  325.      this so that linked-in Motif widgets don't get themselves wedged.
  326.    */
  327.   if (selection_atom == DEVICE_XATOM_CLIPBOARD (d)
  328.       && STRINGP (selection_value)
  329.  
  330.       /* If we already own the clipboard, don't own it again in the Motif
  331.      way.  This might lose in some subtle way, since the timestamp won't
  332.      be current, but owning the selection on the Motif way does a
  333.      SHITLOAD of X protocol, and it makes killing text be incredibly
  334.      slow when using an X terminal.  ARRRRGGGHHH!!!!
  335.        */
  336.       /* No, this is no good, because then Motif text fields don't bother
  337.      to look up the new value, and you can't Copy from a buffer, Paste
  338.      into a text field, then Copy something else from the buffer and
  339.      paste it intot he text field -- it pastes the first thing again. */
  340. /*      && !owned_p */
  341.       )
  342.     {
  343. #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
  344.       Widget widget = FRAME_X_TEXT_WIDGET (selected_frame());
  345. #endif
  346.       long itemid;
  347. #if XmVersion >= 1002
  348.       long dataid;
  349. #else
  350.       int dataid;    /* 1.2 wants long, but 1.1.5 wants int... */
  351. #endif
  352.       XmString fmh;
  353.       fmh = XmStringCreateLtoR ("Clipboard", XmSTRING_DEFAULT_CHARSET);
  354.       while (ClipboardSuccess !=
  355.          XmClipboardStartCopy (display, selecting_window, fmh, time,
  356. #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
  357.                    widget, motif_clipboard_cb,
  358. #else
  359.                    0, NULL,
  360. #endif
  361.                    &itemid))
  362.     ;
  363.       XmStringFree (fmh);
  364.       while (ClipboardSuccess !=
  365.          XmClipboardCopy (display, selecting_window, itemid, "STRING",
  366. #ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
  367.                   /* O'Reilly examples say size can be 0, 
  368.                  but this clearly is not the case. */
  369.                   0, string_length (XSTRING (selection_value)) + 1,
  370.                   (int) selecting_window, /* private id */
  371. #else /* !MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
  372.                   (char *) string_data (XSTRING (selection_value)),
  373.                   string_length (XSTRING (selection_value)) + 1,
  374.                   0,
  375. #endif /* !MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
  376.                   &dataid))
  377.     ;
  378.       while (ClipboardSuccess !=
  379.          XmClipboardEndCopy (display, selecting_window, itemid))
  380.     ;
  381.     }
  382. }
  383.  
  384. # ifdef MOTIF_INCREMENTAL_CLIPBOARDS_WORK
  385. /* I tried to treat the clipboard like a real selection, and not send
  386.    the data until it was requested, but it looks like that just doesn't
  387.    work at all unless the selection owner and requestor are in different
  388.    processes.  From reading the Motif source, it looks like they never
  389.    even considered having two widgets in the same application transfer
  390.    data between each other using "by-name" clipboard values.  What a
  391.    bunch of fuckups.
  392.  */
  393. static void
  394. motif_clipboard_cb (Widget widget, int *data_id, int *private_id, int *reason)
  395. {
  396.   switch (*reason)
  397.     {
  398.     case XmCR_CLIPBOARD_DATA_REQUEST:
  399.       {
  400.     Display *dpy = XtDisplay (widget);
  401.     Window window = (Window) *private_id;
  402.     Lisp_Object selection = assq_no_quit (QCLIPBOARD, Vselection_alist);
  403.     if (NILP (selection)) abort ();
  404.     selection = XCDR (selection);
  405.     if (!STRINGP (selection)) abort ();
  406.     XmClipboardCopyByName (dpy, window, *data_id,
  407.                    (char *) string_data (XSTRING (selection)),
  408.                    string_length (XSTRING (selection)) + 1,
  409.                    0);
  410.       }
  411.       break;
  412.     case XmCR_CLIPBOARD_DATA_DELETE:
  413.     default:
  414.       /* don't need to free anything */
  415.       break;
  416.     }
  417. }
  418. # endif /* MOTIF_INCREMENTAL_CLIPBOARDS_WORK */
  419. #endif /* MOTIF_CLIPBOARDS */
  420.  
  421.  
  422. /* Given a selection-name and desired type, this looks up our local copy of
  423.    the selection value and converts it to the type.  It returns nil or a
  424.    string.  This calls random elisp code, and may signal or gc.
  425.  */
  426. static Lisp_Object
  427. x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type)
  428. {
  429.   /* This function can GC */
  430.   Lisp_Object local_value = assq_no_quit (selection_symbol, Vselection_alist);
  431.   Lisp_Object handler_fn, value, check;
  432.  
  433.   if (NILP (local_value)) return Qnil;
  434.  
  435.   /* TIMESTAMP and MULTIPLE are special cases 'cause that's easiest. */
  436.   if (EQ (target_type, QTIMESTAMP))
  437.     {
  438.       handler_fn = Qnil;
  439.       value = XCAR (XCDR (XCDR (local_value)));
  440.     }
  441.  
  442. #if 0 /* #### MULTIPLE doesn't work yet */
  443.   else if (CONSP (target_type) &&
  444.        XCAR (target_type) == QMULTIPLE)
  445.     {
  446.       Lisp_Object pairs = XCDR (target_type);
  447.       int size = XVECTOR (pairs)->size;
  448.       int i;
  449.       /* If the target is MULTIPLE, then target_type looks like
  450.       (MULTIPLE . [[SELECTION1 TARGET1] [SELECTION2 TARGET2] ... ])
  451.      We modify the second element of each pair in the vector and
  452.      return it as [[SELECTION1 <value1>] [SELECTION2 <value2>] ... ]
  453.        */
  454.       for (i = 0; i < size; i++)
  455.     {
  456.       Lisp_Object pair = vector_data (XVECTOR (pairs)) [i];
  457.       vector_data (XVECTOR (pair)) [1] =
  458.         x_get_local_selection (vector_data (XVECTOR (pair)) [0],
  459.                    vector_data (XVECTOR (pair)) [1]);
  460.     }
  461.       return pairs;
  462.     }
  463. #endif
  464.   else
  465.     {
  466.       CHECK_SYMBOL (target_type, 0);
  467.       handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
  468.       if (NILP (handler_fn)) return Qnil;
  469.       value = call3 (handler_fn,
  470.              selection_symbol, target_type,
  471.              XCAR (XCDR (local_value)));
  472.     }
  473.  
  474.   /* This lets the selection function to return (TYPE . VALUE).  For example,
  475.      when the selected type is LINE_NUMBER, the returned type is SPAN, not
  476.      INTEGER.
  477.    */
  478.   check = value;
  479.   if (CONSP (value) && SYMBOLP (XCAR (value)))
  480.     check = XCDR (value);
  481.   
  482.   /* Strings, vectors, and symbols are converted to selection data format in
  483.      the obvious way.  Integers are converted to 16 bit quantities if they're
  484.      small enough, otherwise 32 bits are used.
  485.    */
  486.   if (STRINGP (check) ||
  487.       VECTORP (check) ||
  488.       SYMBOLP (check) ||
  489.       INTP (check) ||
  490.       NILP (value))
  491.     return value;
  492.  
  493.   /* (N . M) or (N M) get turned into a 32 bit quantity.  So if you want to
  494.      always return a small quantity as 32 bits, your converter routine needs
  495.      to return a cons.
  496.    */
  497.   else if (CONSP (check) &&
  498.        INTP (XCAR (check)) &&
  499.        (INTP (XCDR (check)) ||
  500.         (CONSP (XCDR (check)) &&
  501.          INTP (XCAR (XCDR (check))) &&
  502.          NILP (XCDR (XCDR (check))))))
  503.     return value;
  504.   /* Otherwise the lisp converter function returned something unrecognised. 
  505.    */
  506.   else
  507.     signal_error (Qerror,
  508.                   list3 (build_string
  509.              ("unrecognised selection-conversion type"),
  510.                          handler_fn,
  511.                          value));
  512.  
  513.   return Qnil;    /* suppress compiler warning */
  514. }
  515.  
  516.  
  517.  
  518. /* Send a SelectionNotify event to the requestor with property=None, meaning
  519.    we were unable to do what they wanted.
  520.  */
  521. static void
  522. x_decline_selection_request (XSelectionRequestEvent *event)
  523. {
  524.   XSelectionEvent reply;
  525.   reply.type = SelectionNotify;
  526.   reply.display = event->display;
  527.   reply.requestor = event->requestor;
  528.   reply.selection = event->selection;
  529.   reply.time = event->time;
  530.   reply.target = event->target;
  531.   reply.property = None;
  532.  
  533.   (void) XSendEvent (reply.display, reply.requestor, False, 0L,
  534.              (XEvent *) &reply);
  535.   XFlush (reply.display);
  536. }
  537.  
  538.  
  539. /* Used as an unwind-protect clause so that, if a selection-converter signals
  540.    an error, we tell the requestor that we were unable to do what they wanted
  541.    before we throw to top-level or go into the debugger or whatever.
  542.  */
  543. static Lisp_Object
  544. x_selection_request_lisp_error (Lisp_Object closure)
  545. {
  546.   XSelectionRequestEvent *event = (XSelectionRequestEvent *)
  547.     get_opaque_ptr (closure);
  548.  
  549.   if (event->type == 0) /* we set this to mean "completed normally" */
  550.     return Qnil;
  551.   x_decline_selection_request (event);
  552.   return Qnil;
  553. }
  554.  
  555.  
  556. /* Convert our selection to the requested type, and put that data where the
  557.    requestor wants it.  Then tell them whether we've succeeded.
  558.  */
  559. static void
  560. x_reply_selection_request (XSelectionRequestEvent *event, int format,
  561.                unsigned char *data, int size, Atom type)
  562. {
  563.   /* This function can GC */
  564.   XSelectionEvent reply;
  565.   Display *display = event->display;
  566.   struct device *d = get_device_from_display (display);
  567.   Window window = event->requestor;
  568.   int bytes_remaining;
  569.   int format_bytes = format/8;
  570.   int max_bytes = SELECTION_QUANTUM (display);
  571.   if (max_bytes > MAX_SELECTION_QUANTUM) max_bytes = MAX_SELECTION_QUANTUM;
  572.  
  573.   reply.type = SelectionNotify;
  574.   reply.display = display;
  575.   reply.requestor = window;
  576.   reply.selection = event->selection;
  577.   reply.time = event->time;
  578.   reply.target = event->target;
  579.   reply.property = (event->property == None ? event->target : event->property);
  580.  
  581.   /* #### XChangeProperty can generate BadAlloc, and we must handle it! */
  582.  
  583.   /* Store the data on the requested property.
  584.      If the selection is large, only store the first N bytes of it.
  585.    */
  586.   bytes_remaining = size * format_bytes;
  587.   if (bytes_remaining <= max_bytes)
  588.     {
  589.       /* Send all the data at once, with minimal handshaking. */
  590. #if 0
  591.       stderr_out ("\nStoring all %d\n", bytes_remaining);
  592. #endif
  593.       XChangeProperty (display, window, reply.property, type, format,
  594.                PropModeReplace, data, size);
  595.       /* At this point, the selection was successfully stored; ack it. */
  596.       (void) XSendEvent (display, window, False, 0L, (XEvent *) &reply);
  597.       XFlush (display);
  598.     }
  599.   else
  600.     {
  601.       /* Send an INCR selection. */
  602.       int prop_id;
  603.  
  604.       if (x_window_to_frame (d, window)) /* #### debug */
  605.     error ("attempt to transfer an INCR to ourself!");
  606. #if 0
  607.       stderr_out ("\nINCR %d\n", bytes_remaining);
  608. #endif
  609.       prop_id = expect_property_change (display, window, reply.property,
  610.                     PropertyDelete);
  611.  
  612.       XChangeProperty (display, window, reply.property, DEVICE_XATOM_INCR (d),
  613.                32, PropModeReplace, (unsigned char *)
  614.                &bytes_remaining, 1);
  615.       XSelectInput (display, window, PropertyChangeMask);
  616.       /* Tell 'em the INCR data is there... */
  617.       (void) XSendEvent (display, window, False, 0L, (XEvent *) &reply);
  618.       XFlush (display);
  619.  
  620.       /* First, wait for the requestor to ack by deleting the property.
  621.      This can run random lisp code (process handlers) or signal.
  622.        */
  623.       wait_for_property_change (prop_id);
  624.  
  625.       while (bytes_remaining)
  626.     {
  627.       int i = ((bytes_remaining < max_bytes)
  628.            ? bytes_remaining
  629.            : max_bytes);
  630.       prop_id = expect_property_change (display, window, reply.property,
  631.                         PropertyDelete);
  632. #if 0
  633.       stderr_out ("  INCR adding %d\n", i);
  634. #endif
  635.       /* Append the next chunk of data to the property. */
  636.       XChangeProperty (display, window, reply.property, type, format,
  637.                PropModeAppend, data, i / format_bytes);
  638.       bytes_remaining -= i;
  639.       data += i;
  640.  
  641.       /* Now wait for the requestor to ack this chunk by deleting the
  642.          property.     This can run random lisp code or signal.
  643.        */
  644.       wait_for_property_change (prop_id);
  645.     }
  646.       /* Now write a zero-length chunk to the property to tell the requestor
  647.      that we're done. */
  648. #if 0
  649.       stderr_out ("  INCR done\n");
  650. #endif
  651.       if (! waiting_for_other_props_on_window (display, window))
  652.     XSelectInput (display, window, 0L);
  653.  
  654.       XChangeProperty (display, window, reply.property, type, format,
  655.                PropModeReplace, data, 0);
  656.     }
  657. }
  658.  
  659.  
  660.  
  661. /* Called from the event-loop in response to a SelectionRequest event.
  662.  */
  663. void
  664. x_handle_selection_request (XSelectionRequestEvent *event)
  665. {
  666.   /* This function can GC */
  667.   struct gcpro gcpro1, gcpro2, gcpro3;
  668.   XSelectionEvent reply;
  669.   Lisp_Object local_selection_data = Qnil;
  670.   Lisp_Object selection_symbol;
  671.   Lisp_Object target_symbol = Qnil;
  672.   Lisp_Object converted_selection = Qnil;
  673.   Time local_selection_time;
  674.   Lisp_Object successful_p = Qnil;
  675.   int count;
  676.   struct device *d = get_device_from_display (event->display);
  677.  
  678.   GCPRO3 (local_selection_data, converted_selection, target_symbol);
  679.  
  680.   reply.type = SelectionNotify;        /* Construct the reply event */
  681.   reply.display = event->display;
  682.   reply.requestor = event->requestor;
  683.   reply.selection = event->selection;
  684.   reply.time = event->time;
  685.   reply.target = event->target;
  686.   reply.property = (event->property == None ? event->target : event->property);
  687.  
  688.   selection_symbol = x_atom_to_symbol (d, event->selection);
  689.  
  690.   local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
  691.   
  692. #if 0
  693. # define CDR(x) (XCDR (x))
  694. # define CAR(x) (XCAR (x))
  695.   /* This list isn't user-visible, so it can't "go bad." */
  696.   if (!CONSP (local_selection_data)) abort ();
  697.   if (!CONSP (CDR (local_selection_data))) abort ();
  698.   if (!CONSP (CDR (CDR (local_selection_data)))) abort ();
  699.   if (!NILP (CDR (CDR (CDR (local_selection_data))))) abort ();
  700.   if (!CONSP (CAR (CDR (CDR (local_selection_data))))) abort ();
  701.   if (!INTP (CAR (CAR (CDR (CDR (local_selection_data)))))) abort ();
  702.   if (!INTP (CDR (CAR (CDR (CDR (local_selection_data)))))) abort ();
  703. # undef CAR
  704. # undef CDR
  705. #endif
  706.  
  707.   if (NILP (local_selection_data))
  708.     {
  709.       /* Someone asked for the selection, but we don't have it any more.
  710.        */
  711.       x_decline_selection_request (event);
  712.       goto DONE_LABEL;
  713.     }
  714.  
  715.   local_selection_time =
  716.     * (Time *) XOPAQUE_DATA (XCAR (XCDR (XCDR (local_selection_data))));
  717.  
  718.   if (event->time != CurrentTime &&
  719.       local_selection_time > event->time)
  720.     {
  721.       /* Someone asked for the selection, and we have one, but not the one
  722.      they're looking for.
  723.        */
  724.       x_decline_selection_request (event);
  725.       goto DONE_LABEL;
  726.     }
  727.  
  728.   count = specpdl_depth ();
  729.   record_unwind_protect (x_selection_request_lisp_error,
  730.              make_opaque_ptr (event));
  731.   target_symbol = x_atom_to_symbol (d, event->target);
  732.  
  733. #if 0 /* #### MULTIPLE doesn't work yet */
  734.   if (EQ (target_symbol, QMULTIPLE))
  735.     target_symbol = fetch_multiple_target (event);
  736. #endif
  737.   
  738.   /* Convert lisp objects back into binary data */
  739.   
  740.   converted_selection =
  741.     x_get_local_selection (selection_symbol, target_symbol);
  742.   
  743.   if (! NILP (converted_selection))
  744.     {
  745.       unsigned char *data;
  746.       unsigned int size;
  747.       int format;
  748.       Atom type;
  749.       lisp_data_to_selection_data (d, converted_selection,
  750.                    &data, &type, &size, &format);
  751.       
  752.       x_reply_selection_request (event, format, data, size, type);
  753.       successful_p = Qt;
  754.       /* Tell x_selection_request_lisp_error() it's cool. */
  755.       event->type = 0;
  756.       xfree (data);
  757.     }
  758.   unbind_to (count, Qnil);
  759.  
  760.  DONE_LABEL:
  761.  
  762.   UNGCPRO;
  763.  
  764.   /* Let random lisp code notice that the selection has been asked for.
  765.    */
  766.   {
  767.     Lisp_Object rest;
  768.     Lisp_Object val = Vx_sent_selection_hooks;
  769.     if (!EQ (val, Qunbound) && !NILP (val))
  770.       {
  771.     if (CONSP (val) && !EQ (XCAR (val), Qlambda))
  772.       for (rest = val; !NILP (rest); rest = Fcdr (rest))
  773.         call3 (Fcar(rest), selection_symbol, target_symbol,
  774.            successful_p);
  775.     else
  776.       call3 (val, selection_symbol, target_symbol,
  777.          successful_p);
  778.       }
  779.   }
  780. }
  781.  
  782.  
  783. /* Called from the event-loop in response to a SelectionClear event.
  784.  */
  785. void
  786. x_handle_selection_clear (XSelectionClearEvent *event)
  787. {
  788.   Display *display = event->display;
  789.   struct device *d = get_device_from_display (display);
  790.   Atom selection = event->selection;
  791.   Time changed_owner_time = event->time;
  792.   
  793.   Lisp_Object selection_symbol, local_selection_data;
  794.   Time local_selection_time;
  795.  
  796.   selection_symbol = x_atom_to_symbol (d, selection);
  797.  
  798.   local_selection_data = assq_no_quit (selection_symbol, Vselection_alist);
  799.  
  800.   /* Well, we already believe that we don't own it, so that's just fine. */
  801.   if (NILP (local_selection_data)) return;
  802.  
  803.   local_selection_time =
  804.     * (Time *) XOPAQUE_DATA (XCAR (XCDR (XCDR (local_selection_data))));
  805.  
  806.   /* This SelectionClear is for a selection that we no longer own, so we can
  807.      disregard it.  (That is, we have reasserted the selection since this
  808.      request was generated.)
  809.    */
  810.   if (changed_owner_time != CurrentTime &&
  811.       local_selection_time > changed_owner_time)
  812.     return;
  813.  
  814.   /* Otherwise, we're really honest and truly being told to drop it.
  815.      Don't use Fdelq() as that may QUIT;.
  816.    */
  817.   if (EQ (local_selection_data, Fcar (Vselection_alist)))
  818.     Vselection_alist = Fcdr (Vselection_alist);
  819.   else
  820.     {
  821.       Lisp_Object rest;
  822.       for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
  823.     if (EQ (local_selection_data, Fcar (XCDR (rest))))
  824.       {
  825.         XCDR (rest) = Fcdr (XCDR (rest));
  826.         break;
  827.       }
  828.     }
  829.  
  830.   /* Let random lisp code notice that the selection has been stolen.
  831.    */
  832.   {
  833.     Lisp_Object rest;
  834.     Lisp_Object val = Vx_lost_selection_hooks;
  835.     if (!EQ (val, Qunbound) && !NILP (val))
  836.       {
  837.     if (CONSP (val) && !EQ (XCAR (val), Qlambda))
  838.       for (rest = val; !NILP (rest); rest = Fcdr (rest))
  839.         call1 (Fcar (rest), selection_symbol);
  840.     else
  841.       call1 (val, selection_symbol);
  842.       }
  843.   }
  844. }
  845.  
  846.  
  847. /* This stuff is so that INCR selections are reentrant (that is, so we can
  848.    be servicing multiple INCR selection requests simultaneously).  I haven't
  849.    actually tested that yet.
  850.  */
  851.  
  852. static int prop_location_tick;
  853.  
  854. static struct prop_location {
  855.   int tick;
  856.   Display *display;
  857.   Window window;
  858.   Atom property;
  859.   int desired_state;
  860.   struct prop_location *next;
  861. } *for_whom_the_bell_tolls;
  862.  
  863.  
  864. static int
  865. property_deleted_p (void *tick)
  866. {
  867.   struct prop_location *rest = for_whom_the_bell_tolls;
  868.   while (rest)
  869.     if (rest->tick == (long) tick)
  870.       return 0;
  871.     else
  872.       rest = rest->next;
  873.   return 1;
  874. }
  875.  
  876. static int
  877. waiting_for_other_props_on_window (Display *display, Window window)
  878. {
  879.   struct prop_location *rest = for_whom_the_bell_tolls;
  880.   while (rest)
  881.     if (rest->display == display && rest->window == window)
  882.       return 1;
  883.     else
  884.       rest = rest->next;
  885.   return 0;
  886. }
  887.  
  888.  
  889. static int
  890. expect_property_change (Display *display, Window window,
  891.             Atom property, int state)
  892. {
  893.   struct prop_location *pl = (struct prop_location *)
  894.     xmalloc (sizeof (struct prop_location));
  895.   pl->tick = ++prop_location_tick;
  896.   pl->display = display;
  897.   pl->window = window;
  898.   pl->property = property;
  899.   pl->desired_state = state;
  900.   pl->next = for_whom_the_bell_tolls;
  901.   for_whom_the_bell_tolls = pl;
  902.   return pl->tick;
  903. }
  904.  
  905. static void
  906. unexpect_property_change (int tick)
  907. {
  908.   struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
  909.   while (rest)
  910.     {
  911.       if (rest->tick == tick)
  912.     {
  913.       if (prev)
  914.         prev->next = rest->next;
  915.       else
  916.         for_whom_the_bell_tolls = rest->next;
  917.       xfree (rest);
  918.       return;
  919.     }
  920.       prev = rest;
  921.       rest = rest->next;
  922.     }
  923. }
  924.  
  925. static void
  926. wait_for_property_change (long tick)
  927. {
  928.   /* This function can GC */
  929.   wait_delaying_user_input (property_deleted_p, (void *) tick);
  930. }
  931.  
  932.  
  933. /* Called from the event-loop in response to a PropertyNotify event.
  934.  */
  935. void
  936. x_handle_property_notify (XPropertyEvent *event)
  937. {
  938.   struct prop_location *prev = 0, *rest = for_whom_the_bell_tolls;
  939.   while (rest)
  940.     {
  941.       if (rest->property == event->atom &&
  942.       rest->window == event->window &&
  943.       rest->display == event->display &&
  944.       rest->desired_state == event->state)
  945.     {
  946. #if 0
  947.       stderr_out ("Saw expected prop-%s on %s\n",
  948.            (event->state == PropertyDelete ? "delete" : "change"),
  949.               (char *) string_data (XSYMBOL (x_atom_to_symbol (get_device_from_display (event->display), event->atom))->name);
  950. #endif
  951.       if (prev)
  952.         prev->next = rest->next;
  953.       else
  954.         for_whom_the_bell_tolls = rest->next;
  955.       xfree (rest);
  956.       return;
  957.     }
  958.       prev = rest;
  959.       rest = rest->next;
  960.     }
  961. #if 0
  962.   stderr_out ("Saw UNexpected prop-%s on %s\n",
  963.        (event->state == PropertyDelete ? "delete" : "change"),
  964.        (char *) string_data (XSYMBOL (x_atom_to_symbol (get_device_from_display (event->display), event->atom))->name));
  965. #endif
  966. }
  967.  
  968.  
  969.  
  970. #if 0 /* #### MULTIPLE doesn't work yet */
  971.  
  972. static Lisp_Object
  973. fetch_multiple_target (XSelectionRequestEvent *event)
  974. {
  975.   /* This function can GC */
  976.   Display *display = event->display;
  977.   Window window = event->requestor;
  978.   Atom target = event->target;
  979.   Atom selection_atom = event->selection;
  980.   int result;
  981.  
  982.   return
  983.     Fcons (QMULTIPLE,
  984.        x_get_window_property_as_lisp_data (display, window, target,
  985.                            QMULTIPLE,
  986.                            selection_atom));
  987. }
  988.  
  989. static Lisp_Object
  990. copy_multiple_data (Lisp_Object obj)
  991. {
  992.   Lisp_Object vec;
  993.   int i;
  994.   int size;
  995.   if (CONSP (obj))
  996.     return Fcons (XCAR (obj), copy_multiple_data (XCDR (obj)));
  997.     
  998.   CHECK_VECTOR (obj, 0);
  999.   size = XVECTOR (obj)->size;
  1000.   vec = make_vector (size, Qnil);
  1001.   for (i = 0; i < size; i++)
  1002.     {
  1003.       Lisp_Object vec2 = vector_data (XVECTOR (obj)) [i];
  1004.       CHECK_VECTOR (vec2, 0);
  1005.       if (XVECTOR (vec2)->size != 2)
  1006.     signal_error (Qerror, list2 (build_string
  1007.                      ("vectors must be of length 2"),
  1008.                                      vec2));
  1009.       vector_data (XVECTOR (vec)) [i] = make_vector (2, Qnil);
  1010.       vector_data (XVECTOR (vector_data (XVECTOR (vec)) [i])) [0] =
  1011.     vector_data (XVECTOR (vec2)) [0];
  1012.       vector_data (XVECTOR (vector_data (XVECTOR (vec)) [i])) [1] =
  1013.     vector_data (XVECTOR (vec2)) [1];
  1014.     }
  1015.   return vec;
  1016. }
  1017.  
  1018. #endif
  1019.  
  1020.  
  1021. static int reading_selection_reply;
  1022. static Atom reading_which_selection;
  1023. static int selection_reply_timed_out;
  1024.  
  1025. static int
  1026. selection_reply_done (void *ignore)
  1027. {
  1028.   return !reading_selection_reply;
  1029. }
  1030.  
  1031. static Lisp_Object Qx_selection_reply_timeout_internal;
  1032.  
  1033. DEFUN ("x-selection-reply-timeout-internal",
  1034.        Fx_selection_reply_timeout_internal,
  1035.        Sx_selection_reply_timeout_internal, 1, 1, 0, "")
  1036.      (arg)
  1037.      Lisp_Object arg;
  1038. {
  1039.   selection_reply_timed_out = 1;
  1040.   reading_selection_reply = 0;
  1041.   return Qnil;
  1042. }
  1043.  
  1044.  
  1045. /* Do protocol to read selection-data from the server.
  1046.    Converts this to lisp data and returns it.
  1047.  */
  1048. static Lisp_Object
  1049. x_get_foreign_selection (Lisp_Object selection_symbol, Lisp_Object target_type)
  1050. {
  1051.   /* This function can GC */
  1052.   struct device *d = get_x_device (Qnil);
  1053.   Display *display = DEVICE_X_DISPLAY (d);
  1054.   struct frame *sel_frame = selected_frame ();
  1055.   Window requestor_window = XtWindow (FRAME_X_TEXT_WIDGET (sel_frame));
  1056.   Time requestor_time = DEVICE_X_MOUSE_TIMESTAMP (d);
  1057.   Atom target_property = DEVICE_XATOM_EMACS_TMP (d);
  1058.   Atom selection_atom = symbol_to_x_atom (d, selection_symbol);
  1059.   Atom type_atom;
  1060.   int speccount;
  1061.  
  1062.   if (CONSP (target_type))
  1063.     type_atom = symbol_to_x_atom (d, XCAR (target_type));
  1064.   else
  1065.     type_atom = symbol_to_x_atom (d, target_type);
  1066.  
  1067.   XConvertSelection (display, selection_atom, type_atom, target_property,
  1068.              requestor_window, requestor_time);
  1069.  
  1070.   /* Block until the reply has been read. */
  1071.   reading_selection_reply = (int) requestor_window;
  1072.   reading_which_selection = selection_atom;
  1073.   selection_reply_timed_out = 0;
  1074.  
  1075.   speccount = specpdl_depth ();
  1076.  
  1077.   /* add a timeout handler */
  1078.   if (x_selection_timeout > 0)
  1079.     {
  1080.       Lisp_Object id = Fadd_timeout (make_number (x_selection_timeout),
  1081.                      Qx_selection_reply_timeout_internal,
  1082.                      Qnil, Qnil);
  1083.       record_unwind_protect (Fdisable_timeout, id);
  1084.     }
  1085.  
  1086.   /* This is ^Gable */
  1087.   wait_delaying_user_input (selection_reply_done, 0);
  1088.  
  1089.   if (selection_reply_timed_out)
  1090.     error ("timed out waiting for reply from selection owner");
  1091.  
  1092.   unbind_to (speccount, Qnil);
  1093.  
  1094.   /* otherwise, the selection is waiting for us on the requested property. */
  1095.   return
  1096.     x_get_window_property_as_lisp_data (display, requestor_window,
  1097.                     target_property, target_type,
  1098.                     selection_atom);
  1099. }
  1100.  
  1101.  
  1102. static void
  1103. x_get_window_property (Display *display, Window window, Atom property,
  1104.                unsigned char **data_ret, int *bytes_ret,
  1105.                Atom *actual_type_ret, int *actual_format_ret,
  1106.                unsigned long *actual_size_ret, int delete_p)
  1107. {
  1108.   int total_size;
  1109.   unsigned long bytes_remaining;
  1110.   int offset = 0;
  1111.   unsigned char *tmp_data = 0;
  1112.   int result;
  1113.   int buffer_size = SELECTION_QUANTUM (display);
  1114.   if (buffer_size > MAX_SELECTION_QUANTUM) buffer_size = MAX_SELECTION_QUANTUM;
  1115.   
  1116.   /* First probe the thing to find out how big it is. */
  1117.   result = XGetWindowProperty (display, window, property,
  1118.                    0, 0, False, AnyPropertyType,
  1119.                    actual_type_ret, actual_format_ret,
  1120.                    actual_size_ret,
  1121.                    &bytes_remaining, &tmp_data);
  1122.   if (result != Success)
  1123.     {
  1124.       *data_ret = 0;
  1125.       *bytes_ret = 0;
  1126.       return;
  1127.     }
  1128.   XFree ((char *) tmp_data);
  1129.   
  1130.   if (*actual_type_ret == None || *actual_format_ret == 0)
  1131.     {
  1132.       if (delete_p) XDeleteProperty (display, window, property);
  1133.       *data_ret = 0;
  1134.       *bytes_ret = 0;
  1135.       return;
  1136.     }
  1137.  
  1138.   total_size = bytes_remaining + 1;
  1139.   *data_ret = (unsigned char *) xmalloc (total_size);
  1140.   
  1141.   /* Now read, until weve gotten it all. */
  1142.   while (bytes_remaining)
  1143.     {
  1144. #if 0
  1145.       int last = bytes_remaining;
  1146. #endif
  1147.       result =
  1148.     XGetWindowProperty (display, window, property,
  1149.                 offset/4, buffer_size/4,
  1150.                 (delete_p ? True : False),
  1151.                 AnyPropertyType,
  1152.                 actual_type_ret, actual_format_ret,
  1153.                 actual_size_ret, &bytes_remaining, &tmp_data);
  1154. #if 0
  1155.       stderr_out ("<< read %d\n", last-bytes_remaining);
  1156. #endif
  1157.       /* If this doesn't return Success at this point, it means that
  1158.      some clod deleted the selection while we were in the midst of
  1159.      reading it.  Deal with that, I guess....
  1160.        */
  1161.       if (result != Success) break;
  1162.       *actual_size_ret *= *actual_format_ret / 8;
  1163.       memcpy ((*data_ret) + offset, tmp_data, *actual_size_ret);
  1164.       offset += *actual_size_ret;
  1165.       XFree ((char *) tmp_data);
  1166.     }
  1167.   *bytes_ret = offset;
  1168. }
  1169.  
  1170.  
  1171. static void
  1172. receive_incremental_selection (Display *display, Window window, Atom property,
  1173.                    /* this one is for error messages only */
  1174.                    Lisp_Object target_type,
  1175.                    unsigned int min_size_bytes,
  1176.                    unsigned char **data_ret, int *size_bytes_ret,
  1177.                    Atom *type_ret, int *format_ret,
  1178.                    unsigned long *size_ret)
  1179. {
  1180.   /* This function can GC */
  1181.   int offset = 0;
  1182.   int prop_id;
  1183.   *size_bytes_ret = min_size_bytes;
  1184.   *data_ret = (unsigned char *) xmalloc (*size_bytes_ret);
  1185. #if 0
  1186.   stderr_out ("\nread INCR %d\n", min_size_bytes);
  1187. #endif
  1188.   /* At this point, we have read an INCR property, and deleted it (which
  1189.      is how we ack its receipt: the sending window will be selecting
  1190.      PropertyNotify events on our window to notice this).
  1191.  
  1192.      Now, we must loop, waiting for the sending window to put a value on
  1193.      that property, then reading the property, then deleting it to ack.
  1194.      We are done when the sender places a property of length 0.
  1195.    */
  1196.   prop_id = expect_property_change (display, window, property,
  1197.                     PropertyNewValue);
  1198.   while (1)
  1199.     {
  1200.       unsigned char *tmp_data;
  1201.       int tmp_size_bytes;
  1202.       wait_for_property_change (prop_id);
  1203.       /* expect it again immediately, because x_get_window_property may
  1204.      .. no it wont, I dont get it.
  1205.      .. Ok, I get it now, the Xt code that implements INCR is broken.
  1206.        */
  1207.       prop_id = expect_property_change (display, window, property,
  1208.                     PropertyNewValue);
  1209.       x_get_window_property (display, window, property,
  1210.                  &tmp_data, &tmp_size_bytes,
  1211.                  type_ret, format_ret, size_ret, 1);
  1212.  
  1213.       if (tmp_size_bytes == 0) /* we're done */
  1214.     {
  1215. #if 0
  1216.       stderr_out ("  read INCR done\n");
  1217. #endif
  1218.       unexpect_property_change (prop_id);
  1219.       if (tmp_data) xfree (tmp_data);
  1220.       break;
  1221.     }
  1222. #if 0
  1223.       stderr_out ("  read INCR %d\n", tmp_size_bytes);
  1224. #endif
  1225.       if (*size_bytes_ret < offset + tmp_size_bytes)
  1226.     {
  1227. #if 0
  1228.       stderr_out ("  read INCR realloc %d -> %d\n",
  1229.            *size_bytes_ret, offset + tmp_size_bytes);
  1230. #endif
  1231.       *size_bytes_ret = offset + tmp_size_bytes;
  1232.       *data_ret = (unsigned char *) xrealloc (*data_ret, *size_bytes_ret);
  1233.     }
  1234.       memcpy ((*data_ret) + offset, tmp_data, tmp_size_bytes);
  1235.       offset += tmp_size_bytes;
  1236.       xfree (tmp_data);
  1237.     }
  1238. }
  1239.  
  1240.  
  1241. static Lisp_Object
  1242. x_get_window_property_as_lisp_data (Display *display,
  1243.                     Window window,
  1244.                     Atom property,
  1245.                     /* next two for error messages only */
  1246.                     Lisp_Object target_type,
  1247.                     Atom selection_atom)
  1248. {
  1249.   /* This function can GC */
  1250.   Atom actual_type;
  1251.   int actual_format;
  1252.   unsigned long actual_size;
  1253.   unsigned char *data = 0;
  1254.   int bytes = 0;
  1255.   Lisp_Object val;
  1256.   struct device *d = get_device_from_display (display);
  1257.  
  1258.   x_get_window_property (display, window, property, &data, &bytes,
  1259.              &actual_type, &actual_format, &actual_size, 1);
  1260.   if (! data)
  1261.     {
  1262.       int there_is_a_selection_owner;
  1263.       there_is_a_selection_owner =
  1264.     XGetSelectionOwner (display, selection_atom);
  1265.       signal_error (Qerror,
  1266.         (there_is_a_selection_owner
  1267.      ? Fcons (build_string ("selection owner couldn't convert"),
  1268.           (actual_type
  1269.            ? list2 (target_type,
  1270.                 x_atom_to_symbol (d, actual_type))
  1271.            : list1 (target_type)))
  1272.      : list2 (build_string ("no selection"),
  1273.           x_atom_to_symbol (d, selection_atom))));
  1274.     }
  1275.   
  1276.   if (actual_type == DEVICE_XATOM_INCR (d))
  1277.     {
  1278.       /* Ok, that data wasnt *the* data, it was just the beginning. */
  1279.  
  1280.       unsigned int min_size_bytes = * ((unsigned int *) data);
  1281.       XFree ((char *) data);
  1282.       receive_incremental_selection (display, window, property, target_type,
  1283.                      min_size_bytes, &data, &bytes,
  1284.                      &actual_type, &actual_format,
  1285.                      &actual_size);
  1286.     }
  1287.  
  1288.   /* It's been read.  Now convert it to a lisp object in some semi-rational
  1289.      manner.
  1290.    */
  1291.   val = selection_data_to_lisp_data (d, data, bytes,
  1292.                      actual_type, actual_format);
  1293.   
  1294.   xfree (data);
  1295.   return val;
  1296. }
  1297.  
  1298. /* These functions convert from the selection data read from the server into
  1299.    something that we can use from elisp, and vice versa.
  1300.  
  1301.     Type:    Format:    Size:        Elisp Type:
  1302.     -----    -------    -----        -----------
  1303.     *    8    *        String
  1304.     ATOM    32    1        Symbol
  1305.     ATOM    32    > 1        Vector of Symbols
  1306.     *    16    1        Integer
  1307.     *    16    > 1        Vector of Integers
  1308.     *    32    1        if <=16 bits: Integer
  1309.                     if > 16 bits: Cons of top16, bot16
  1310.     *    32    > 1        Vector of the above
  1311.  
  1312.    When converting a Lisp number to C, it is assumed to be of format 16 if
  1313.    it is an integer, and of format 32 if it is a cons of two integers.
  1314.  
  1315.    When converting a vector of numbers from Elisp to C, it is assumed to be
  1316.    of format 16 if every element in the vector is an integer, and is assumed
  1317.    to be of format 32 if any element is a cons of two integers.
  1318.  
  1319.    When converting an object to C, it may be of the form (SYMBOL . <data>)
  1320.    where SYMBOL is what we should claim that the type is.  Format and
  1321.    representation are as above.
  1322.  */
  1323.  
  1324.  
  1325. static Lisp_Object
  1326. selection_data_to_lisp_data (struct device *d,
  1327.                  unsigned char *data,
  1328.                  int size,
  1329.                  Atom type,
  1330.                  int format)
  1331. {
  1332.   if (type == DEVICE_XATOM_NULL (d))
  1333.     return QNULL;
  1334.  
  1335.   /* Convert any 8-bit data to a string, for compactness. */
  1336.   else if (format == 8)
  1337.     return make_string (data, size);
  1338.  
  1339.   /* Convert a single atom to a Lisp_Symbol.  Convert a set of atoms to
  1340.      a vector of symbols.
  1341.    */
  1342.   else if (type == XA_ATOM)
  1343.     {
  1344.       int i;
  1345.       if (size == sizeof (Atom))
  1346.     return x_atom_to_symbol (d, *((Atom *) data));
  1347.       else
  1348.     {
  1349.       Lisp_Object v = Fmake_vector (make_number (size / sizeof (Atom)),
  1350.                     Qzero);
  1351.       for (i = 0; i < size / sizeof (Atom); i++)
  1352.         Faset (v, make_number (i),
  1353.            x_atom_to_symbol (d, ((Atom *) data) [i]));
  1354.       return v;
  1355.     }
  1356.     }
  1357.  
  1358.   /* Convert a single 16 or small 32 bit number to a Lisp_Int.
  1359.      If the number is > 16 bits, convert it to a cons of integers,
  1360.      16 bits in each half.
  1361.    */
  1362.   else if (format == 32 && size == sizeof (long))
  1363.     return word_to_lisp (((unsigned long *) data) [0]);
  1364.   else if (format == 16 && size == sizeof (short))
  1365.     return make_number ((int) (((unsigned short *) data) [0]));
  1366.  
  1367.   /* Convert any other kind of data to a vector of numbers, represented
  1368.      as above (as an integer, or a cons of two 16 bit integers).
  1369.  
  1370.      #### Perhaps we should return the actual type to lisp as well.
  1371.  
  1372.     (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
  1373.     ==> [4 4]
  1374.  
  1375.      and perhaps it should be
  1376.  
  1377.     (x-get-selection-internal 'PRIMARY 'LINE_NUMBER)
  1378.     ==> (SPAN . [4 4])
  1379.  
  1380.      Right now the fact that the return type was SPAN is discarded before
  1381.      lisp code gets to see it.
  1382.    */
  1383.   else if (format == 16)
  1384.     {
  1385.       int i;
  1386.       Lisp_Object v = make_vector (size / 4, Qzero);
  1387.       for (i = 0; i < size / 4; i++)
  1388.     {
  1389.       int j = (int) ((unsigned short *) data) [i];
  1390.       Faset (v, make_number (i), make_number (j));
  1391.     }
  1392.       return v;
  1393.     }
  1394.   else
  1395.     {
  1396.       int i;
  1397.       Lisp_Object v = make_vector (size / 4, Qzero);
  1398.       for (i = 0; i < size / 4; i++)
  1399.     {
  1400.       unsigned long j = ((unsigned long *) data) [i];
  1401.       Faset (v, make_number (i), word_to_lisp (j));
  1402.     }
  1403.       return v;
  1404.     }
  1405. }
  1406.  
  1407.  
  1408. static void
  1409. lisp_data_to_selection_data (struct device *d,
  1410.                  Lisp_Object obj,
  1411.                  unsigned char **data_ret,
  1412.                  Atom *type_ret,
  1413.                  unsigned int *size_ret,
  1414.                  int *format_ret)
  1415. {
  1416.   Lisp_Object type = Qnil;
  1417.  
  1418.   if (CONSP (obj) && SYMBOLP (XCAR (obj)))
  1419.     {
  1420.       type = XCAR (obj);
  1421.       obj = XCDR (obj);
  1422.       if (CONSP (obj) && NILP (XCDR (obj)))
  1423.     obj = XCAR (obj);
  1424.     }
  1425.  
  1426.   if (EQ (obj, QNULL) || (EQ (type, QNULL)))
  1427.     {                /* This is not the same as declining */
  1428.       *format_ret = 32;
  1429.       *size_ret = 0;
  1430.       *data_ret = 0;
  1431.       type = QNULL;
  1432.     }
  1433.   else if (STRINGP (obj))
  1434.     {
  1435.       *format_ret = 8;
  1436.       *size_ret = string_length (XSTRING (obj));
  1437.       *data_ret = (unsigned char *) xmalloc (*size_ret);
  1438.       memcpy (*data_ret, (char *) string_data (XSTRING (obj)), *size_ret);
  1439.       if (NILP (type)) type = QSTRING;
  1440.     }
  1441.   else if (SYMBOLP (obj))
  1442.     {
  1443.       *format_ret = 32;
  1444.       *size_ret = 1;
  1445.       *data_ret = (unsigned char *) xmalloc (sizeof (Atom) + 1);
  1446.       (*data_ret) [sizeof (Atom)] = 0;
  1447.       (*(Atom **) data_ret) [0] = symbol_to_x_atom (d, obj);
  1448.       if (NILP (type)) type = QATOM;
  1449.     }
  1450.   else if (INTP (obj) &&
  1451.        XINT (obj) < 0xFFFF &&
  1452.        XINT (obj) > -0xFFFF)
  1453.     {
  1454.       *format_ret = 16;
  1455.       *size_ret = 1;
  1456.       *data_ret = (unsigned char *) xmalloc (sizeof (short) + 1);
  1457.       (*data_ret) [sizeof (short)] = 0;
  1458.       (*(short **) data_ret) [0] = (short) XINT (obj);
  1459.       if (NILP (type)) type = QINTEGER;
  1460.     }
  1461.   else if (INTP (obj) || CONSP (obj))
  1462.     {
  1463.       *format_ret = 32;
  1464.       *size_ret = 1;
  1465.       *data_ret = (unsigned char *) xmalloc (sizeof (long) + 1);
  1466.       (*data_ret) [sizeof (long)] = 0;
  1467.       (*(unsigned long **) data_ret) [0] = lisp_to_word (obj);
  1468.       if (NILP (type)) type = QINTEGER;
  1469.     }
  1470.   else if (VECTORP (obj))
  1471.     {
  1472.       /* Lisp_Vectors may represent a set of ATOMs;
  1473.      a set of 16 or 32 bit INTEGERs;
  1474.      or a set of ATOM_PAIRs (represented as [[A1 A2] [A3 A4] ...]
  1475.        */
  1476.       int i;
  1477.  
  1478.       if (SYMBOLP (vector_data (XVECTOR (obj)) [0]))
  1479.     /* This vector is an ATOM set */
  1480.     {
  1481.       if (NILP (type)) type = QATOM;
  1482.       *size_ret = XVECTOR (obj)->size;
  1483.       *format_ret = 32;
  1484.       *data_ret = (unsigned char *) xmalloc ((*size_ret) * sizeof (Atom));
  1485.       for (i = 0; i < *size_ret; i++)
  1486.         if (SYMBOLP (vector_data (XVECTOR (obj)) [i]))
  1487.           (*(Atom **) data_ret) [i] =
  1488.         symbol_to_x_atom (d, vector_data (XVECTOR (obj)) [i]);
  1489.         else
  1490.               signal_error (Qerror, /* Qselection_error */
  1491.                             list2 (build_string
  1492.            ("all elements of the vector must be of the same type"),
  1493.                                    obj));
  1494.     }
  1495. #if 0 /* #### MULTIPLE doesn't work yet */
  1496.       else if (VECTORP (vector_data (XVECTOR (obj)) [0]))
  1497.     /* This vector is an ATOM_PAIR set */
  1498.     {
  1499.       if (NILP (type)) type = QATOM_PAIR;
  1500.       *size_ret = XVECTOR (obj)->size;
  1501.       *format_ret = 32;
  1502.       *data_ret = (unsigned char *)
  1503.         xmalloc ((*size_ret) * sizeof (Atom) * 2);
  1504.       for (i = 0; i < *size_ret; i++)
  1505.         if (VECTORP (vector_data (XVECTOR (obj)) [i]))
  1506.           {
  1507.         Lisp_Object pair = vector_data (XVECTOR (obj)) [i];
  1508.         if (XVECTOR (pair)->size != 2)
  1509.           signal_error (Qerror,
  1510.                                 list2 (build_string 
  1511.        ("elements of the vector must be vectors of exactly two elements"),
  1512.                   pair));
  1513.         
  1514.         (*(Atom **) data_ret) [i * 2] =
  1515.           symbol_to_x_atom (d, vector_data (XVECTOR (pair)) [0]);
  1516.         (*(Atom **) data_ret) [(i * 2) + 1] =
  1517.           symbol_to_x_atom (d, vector_data (XVECTOR (pair)) [1]);
  1518.           }
  1519.         else
  1520.           signal_error (Qerror,
  1521.                             list2 (build_string
  1522.            ("all elements of the vector must be of the same type"),
  1523.                                    obj));
  1524.     }
  1525. #endif
  1526.       else
  1527.     /* This vector is an INTEGER set, or something like it */
  1528.     {
  1529.       *size_ret = XVECTOR (obj)->size;
  1530.       if (NILP (type)) type = QINTEGER;
  1531.       *format_ret = 16;
  1532.       for (i = 0; i < *size_ret; i++)
  1533.         if (CONSP (vector_data (XVECTOR (obj)) [i]))
  1534.           *format_ret = 32;
  1535.         else if (!INTP (vector_data (XVECTOR (obj)) [i]))
  1536.           signal_error (Qerror, /* Qselection_error */
  1537.                             list2 (build_string
  1538.     ("all elements of the vector must be integers or conses of integers"),
  1539.                                    obj));
  1540.  
  1541.       *data_ret = (unsigned char *) xmalloc (*size_ret * (*format_ret/8));
  1542.       for (i = 0; i < *size_ret; i++)
  1543.         if (*format_ret == 32)
  1544.           (*((unsigned long **) data_ret)) [i] =
  1545.         lisp_to_word (vector_data (XVECTOR (obj)) [i]);
  1546.         else
  1547.           (*((unsigned short **) data_ret)) [i] =
  1548.         (unsigned short) lisp_to_word (vector_data (XVECTOR (obj)) [i]);
  1549.     }
  1550.     }
  1551.   else
  1552.     signal_error (Qerror, /* Qselection_error */
  1553.                   list2 (build_string ("unrecognised selection data"),
  1554.                          obj));
  1555.  
  1556.   *type_ret = symbol_to_x_atom (d, type);
  1557. }
  1558.  
  1559. static Lisp_Object
  1560. clean_local_selection_data (Lisp_Object obj)
  1561. {
  1562.   if (CONSP (obj) &&
  1563.       INTP (XCAR (obj)) &&
  1564.       CONSP (XCDR (obj)) &&
  1565.       INTP (XCAR (XCDR (obj))) &&
  1566.       NILP (XCDR (XCDR (obj))))
  1567.     obj = Fcons (XCAR (obj), XCDR (obj));
  1568.  
  1569.   if (CONSP (obj) &&
  1570.       INTP (XCAR (obj)) &&
  1571.       INTP (XCDR (obj)))
  1572.     {
  1573.       if (XINT (XCAR (obj)) == 0)
  1574.     return XCDR (obj);
  1575.       if (XINT (XCAR (obj)) == -1)
  1576.     return make_number (- XINT (XCDR (obj)));
  1577.     }
  1578.   if (VECTORP (obj))
  1579.     {
  1580.       int i;
  1581.       int size = XVECTOR (obj)->size;
  1582.       Lisp_Object copy;
  1583.       if (size == 1)
  1584.     return clean_local_selection_data (vector_data (XVECTOR (obj)) [0]);
  1585.       copy = make_vector (size, Qnil);
  1586.       for (i = 0; i < size; i++)
  1587.     vector_data (XVECTOR (copy)) [i] =
  1588.       clean_local_selection_data (vector_data (XVECTOR (obj)) [i]);
  1589.       return copy;
  1590.     }
  1591.   return obj;
  1592. }
  1593.  
  1594.  
  1595. /* Called from the event loop to handle SelectionNotify events.
  1596.    I don't think this needs to be reentrant.
  1597.  */
  1598. void
  1599. x_handle_selection_notify (XSelectionEvent *event)
  1600. {
  1601.   if (! reading_selection_reply)
  1602.     {
  1603.       message ("received an unexpected SelectionNotify event");
  1604.       return;
  1605.     }
  1606.   if (event->requestor != reading_selection_reply)
  1607.     {
  1608.       message ("received a SelectionNotify event for the wrong window");
  1609.       return;
  1610.     }
  1611.   if (event->selection != reading_which_selection)
  1612.     {
  1613.       message ("received the wrong selection type in SelectionNotify!");
  1614.       return;
  1615.     }
  1616.  
  1617.   reading_selection_reply = 0; /* we're done now. */
  1618. }
  1619.  
  1620.  
  1621. DEFUN ("x-own-selection-internal",
  1622.        Fx_own_selection_internal, Sx_own_selection_internal,
  1623.   2, 2, 0,
  1624.   "Assert an X selection of the given TYPE with the given VALUE.\n\
  1625. TYPE is a symbol, typically PRIMARY, SECONDARY, or CLIPBOARD.\n\
  1626. VALUE is typically a string, or a cons of two markers, but may be\n\
  1627. anything that the functions on selection-converter-alist know about.")
  1628.   (selection_name, selection_value)
  1629.      Lisp_Object selection_name, selection_value;
  1630. {
  1631.   CHECK_SYMBOL (selection_name, 0);
  1632.   if (NILP (selection_value)) error ("selection-value may not be nil.");
  1633.   x_own_selection (selection_name, selection_value);
  1634.   return selection_value;
  1635. }
  1636.  
  1637.  
  1638. /* Request the selection value from the owner.  If we are the owner,
  1639.    simply return our selection value.  If we are not the owner, this
  1640.    will block until all of the data has arrived.
  1641.  */
  1642. DEFUN ("x-get-selection-internal",
  1643.        Fx_get_selection_internal, Sx_get_selection_internal, 2, 2, 0,
  1644.   "Return text selected from some X window.\n\
  1645. SELECTION is a symbol, typically PRIMARY, SECONDARY, or CLIPBOARD.\n\
  1646. TYPE is the type of data desired, typically STRING.")
  1647.   (selection_symbol, target_type)
  1648.      Lisp_Object selection_symbol, target_type;
  1649. {
  1650.   /* This function can GC */
  1651.   Lisp_Object val = Qnil;
  1652.   struct gcpro gcpro1, gcpro2;
  1653.   GCPRO2 (target_type, val); /* we store newly consed data into these */
  1654.   CHECK_SYMBOL (selection_symbol, 0);
  1655.  
  1656. #if 0 /* #### MULTIPLE doesn't work yet */
  1657.   if (CONSP (target_type) &&
  1658.       XCAR (target_type) == QMULTIPLE)
  1659.     {
  1660.       CHECK_VECTOR (XCDR (target_type), 0);
  1661.       /* So we don't destructively modify this... */
  1662.       target_type = copy_multiple_data (target_type);
  1663.     }
  1664.   else
  1665. #endif
  1666.     CHECK_SYMBOL (target_type, 0);
  1667.  
  1668.   val = x_get_local_selection (selection_symbol, target_type);
  1669.  
  1670.   if (NILP (val))
  1671.     {
  1672.       val = x_get_foreign_selection (selection_symbol,
  1673.                      target_type);
  1674.       goto DONE_LABEL;
  1675.     }
  1676.  
  1677.   if (CONSP (val) &&
  1678.       SYMBOLP (XCAR (val)))
  1679.     {
  1680.       val = XCDR (val);
  1681.       if (CONSP (val) && NILP (XCDR (val)))
  1682.     val = XCAR (val);
  1683.     }
  1684.   val = clean_local_selection_data (val);
  1685.  DONE_LABEL:
  1686.   UNGCPRO;
  1687.   return val;
  1688. }
  1689.  
  1690. DEFUN ("x-disown-selection-internal",
  1691.        Fx_disown_selection_internal, Sx_disown_selection_internal, 1, 2, 0,
  1692.  "If we own the named selection, then disown it (make there be no selection).")
  1693.      (selection, time)
  1694.      Lisp_Object selection;
  1695.      Lisp_Object time;
  1696. {
  1697.   struct device *d = get_x_device (Qnil);
  1698.   Display *display = DEVICE_X_DISPLAY (d);
  1699.   Time timestamp;
  1700.   Atom selection_atom;
  1701.   XSelectionClearEvent event;
  1702.  
  1703.   CHECK_SYMBOL (selection, 0);
  1704.   if (NILP (time))
  1705.     timestamp = DEVICE_X_MOUSE_TIMESTAMP (d);
  1706.   else
  1707.     {
  1708.       /* #### This is bogus.  See the comment above about problems
  1709.      on OSF/1 and DEC Alphas.  Yet another reason why it sucks
  1710.      to have the implementation (i.e. cons of two 16-bit
  1711.      integers) exposed. */
  1712.       time_t the_time;
  1713.       lisp_to_time (time, &the_time);
  1714.       timestamp = (Time) the_time;
  1715.     }
  1716.  
  1717.   if (NILP (assq_no_quit (selection, Vselection_alist)))
  1718.     return Qnil;  /* Don't disown the selection when we're not the owner. */
  1719.  
  1720.   selection_atom = symbol_to_x_atom (d, selection);
  1721.  
  1722.   XSetSelectionOwner (display, selection_atom, None, timestamp);
  1723.  
  1724.   /* It doesn't seem to be guaranteed that a SelectionClear event will be
  1725.      generated for a window which owns the selection when that window sets
  1726.      the selection owner to None.  The NCD server does, the MIT Sun4 server
  1727.      doesn't.  So we synthesize one; this means we might get two, but
  1728.      that's ok, because the second one won't have any effect.
  1729.    */
  1730.   event.display = display;
  1731.   event.selection = selection_atom;
  1732.   event.time = timestamp;
  1733.   x_handle_selection_clear (&event);
  1734.  
  1735.   return Qt;
  1736. }
  1737.  
  1738.  
  1739. DEFUN ("x-selection-owner-p",
  1740.        Fx_selection_owner_p, Sx_selection_owner_p, 0, 1, 0,
  1741.        "Whether the current emacs process owns the given X Selection.\n\
  1742. The arg should be the name of the selection in question, typically one of\n\
  1743. the symbols PRIMARY, SECONDARY, or CLIPBOARD.  (For convenience, the symbol\n\
  1744. nil is the same as PRIMARY, and t is the same as SECONDARY.)")
  1745.      (selection)
  1746.      Lisp_Object selection;
  1747. {
  1748.   CHECK_SYMBOL (selection, 0);
  1749.   if (EQ (selection, Qnil)) selection = QPRIMARY;
  1750.   if (EQ (selection, Qt)) selection = QSECONDARY;
  1751.   
  1752.   if (NILP (Fassq (selection, Vselection_alist)))
  1753.     return Qnil;
  1754.   return Qt;
  1755. }
  1756.  
  1757. DEFUN ("x-selection-exists-p",
  1758.        Fx_selection_exists_p, Sx_selection_exists_p, 0, 1, 0,
  1759.        "Whether there is an owner for the given X Selection.\n\
  1760. The arg should be the name of the selection in question, typically one of\n\
  1761. the symbols PRIMARY, SECONDARY, or CLIPBOARD.  (For convenience, the symbol\n\
  1762. nil is the same as PRIMARY, and t is the same as SECONDARY.)")
  1763.      (selection)
  1764.      Lisp_Object selection;
  1765. {
  1766.   Window owner;
  1767.   struct device *d = get_x_device (Qnil);
  1768.   Display *dpy = DEVICE_X_DISPLAY (d);
  1769.   CHECK_SYMBOL (selection, 0);
  1770.   if (!NILP (Fx_selection_owner_p (selection)))
  1771.     return Qt;
  1772.   owner = XGetSelectionOwner (dpy, symbol_to_x_atom (d, selection));
  1773.   return (owner ? Qt : Qnil);
  1774. }
  1775.  
  1776.  
  1777. #ifdef CUT_BUFFER_SUPPORT
  1778.  
  1779. static int cut_buffers_initialized; /* Whether we're sure they all exist */
  1780.  
  1781. /* Ensure that all 8 cut buffers exist.  ICCCM says we gotta... */
  1782. static void
  1783. initialize_cut_buffers (Display *display, Window window)
  1784. {
  1785.   unsigned char *data = (unsigned char *) "";
  1786. #define FROB(atom) XChangeProperty (display, window, atom, XA_STRING, 8, \
  1787.                     PropModeAppend, data, 0)
  1788.   FROB (XA_CUT_BUFFER0);
  1789.   FROB (XA_CUT_BUFFER1);
  1790.   FROB (XA_CUT_BUFFER2);
  1791.   FROB (XA_CUT_BUFFER3);
  1792.   FROB (XA_CUT_BUFFER4);
  1793.   FROB (XA_CUT_BUFFER5);
  1794.   FROB (XA_CUT_BUFFER6);
  1795.   FROB (XA_CUT_BUFFER7);
  1796. #undef FROB
  1797.   cut_buffers_initialized = 1;
  1798. }
  1799.  
  1800.  
  1801. #define CHECK_CUTBUFFER(symbol,n)                    \
  1802.   { CHECK_SYMBOL((symbol),(n));                        \
  1803.     if (!EQ((symbol),QCUT_BUFFER0) && !EQ((symbol),QCUT_BUFFER1) &&    \
  1804.     !EQ((symbol),QCUT_BUFFER2) && !EQ((symbol),QCUT_BUFFER3) &&    \
  1805.     !EQ((symbol),QCUT_BUFFER4) && !EQ((symbol),QCUT_BUFFER5) &&    \
  1806.     !EQ((symbol),QCUT_BUFFER6) && !EQ((symbol),QCUT_BUFFER7))    \
  1807.       signal_error (Qerror, list2 (build_string ("doesn't name a cutbuffer"), \
  1808.                                    (symbol))); \
  1809.   }
  1810.  
  1811. DEFUN ("x-get-cutbuffer-internal", Fx_get_cutbuffer_internal,
  1812.        Sx_get_cutbuffer_internal, 1, 1, 0,
  1813.        "Return the value of the named cutbuffer (typically CUT_BUFFER0).")
  1814.      (buffer)
  1815.      Lisp_Object buffer;
  1816. {
  1817.   struct device *d = get_x_device (Qnil);
  1818.   Display *display = DEVICE_X_DISPLAY (d);
  1819.   Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
  1820.   Atom buffer_atom;
  1821.   unsigned char *data;
  1822.   int bytes;
  1823.   Atom type;
  1824.   int format;
  1825.   unsigned long size;
  1826.   Lisp_Object ret;
  1827.  
  1828.   CHECK_CUTBUFFER (buffer, 0);
  1829.   buffer_atom = symbol_to_x_atom (d, buffer);
  1830.  
  1831.   x_get_window_property (display, window, buffer_atom, &data, &bytes,
  1832.              &type, &format, &size, 0);
  1833.   if (!data) return Qnil;
  1834.   
  1835.   if (format != 8 || type != XA_STRING)
  1836.     signal_simple_error_2 ("cut buffer doesn't contain 8-bit data",
  1837.                x_atom_to_symbol (d, type),
  1838.                make_number (format));
  1839.  
  1840.   ret = (bytes ? make_string (data, bytes) : Qnil);
  1841.   xfree (data);
  1842.   return ret;
  1843. }
  1844.  
  1845.  
  1846. DEFUN ("x-store-cutbuffer-internal", Fx_store_cutbuffer_internal,
  1847.        Sx_store_cutbuffer_internal, 2, 2, 0,
  1848.        "Sets the value of the named cutbuffer (typically CUT_BUFFER0).")
  1849.      (buffer, string)
  1850.      Lisp_Object buffer, string;
  1851. {
  1852.   struct device *d = get_x_device (Qnil);
  1853.   Display *display = DEVICE_X_DISPLAY (d);
  1854.   Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
  1855.   Atom buffer_atom;
  1856.   unsigned char *data;
  1857.   int bytes;
  1858.   int bytes_remaining;
  1859.   int max_bytes = SELECTION_QUANTUM (display);
  1860.   if (max_bytes > MAX_SELECTION_QUANTUM) max_bytes = MAX_SELECTION_QUANTUM;
  1861.  
  1862.   CHECK_CUTBUFFER (buffer, 0);
  1863.   CHECK_STRING (string, 0);
  1864.   buffer_atom = symbol_to_x_atom (d, buffer);
  1865.   data = (unsigned char *) string_data (XSTRING (string));
  1866.   bytes = string_length (XSTRING (string));
  1867.   bytes_remaining = bytes;
  1868.  
  1869.   if (! cut_buffers_initialized) initialize_cut_buffers (display, window);
  1870.  
  1871.   while (bytes_remaining)
  1872.     {
  1873.       int chunk = (bytes_remaining < max_bytes
  1874.            ? bytes_remaining : max_bytes);
  1875.       XChangeProperty (display, window, buffer_atom, XA_STRING, 8,
  1876.                (bytes_remaining == bytes
  1877.             ? PropModeReplace
  1878.             : PropModeAppend),
  1879.                data, chunk);
  1880.       data += chunk;
  1881.       bytes_remaining -= chunk;
  1882.     }
  1883.   return string;
  1884. }
  1885.  
  1886.  
  1887. DEFUN ("x-rotate-cutbuffers-internal", Fx_rotate_cutbuffers_internal,
  1888.        Sx_rotate_cutbuffers_internal, 1, 1, 0,
  1889.        "Rotate the values of the cutbuffers by the given number of steps;\n\
  1890. positive means move values forward, negative means backward.")
  1891.      (n)
  1892.      Lisp_Object n;
  1893. {
  1894.   struct device *d = get_x_device (Qnil);
  1895.   Display *display = DEVICE_X_DISPLAY (d);
  1896.   Window window = RootWindow (display, 0); /* Cutbuffers are on frame 0 */
  1897.   Atom props [8];
  1898.  
  1899.   CHECK_INT (n, 0);
  1900.   if (XINT (n) == 0)
  1901.     return n;
  1902.   if (! cut_buffers_initialized)
  1903.     initialize_cut_buffers (display, window);
  1904.   props[0] = XA_CUT_BUFFER0;
  1905.   props[1] = XA_CUT_BUFFER1;
  1906.   props[2] = XA_CUT_BUFFER2;
  1907.   props[3] = XA_CUT_BUFFER3;
  1908.   props[4] = XA_CUT_BUFFER4;
  1909.   props[5] = XA_CUT_BUFFER5;
  1910.   props[6] = XA_CUT_BUFFER6;
  1911.   props[7] = XA_CUT_BUFFER7;
  1912.   XRotateWindowProperties (display, window, props, 8, XINT (n));
  1913.   return n;
  1914. }
  1915.  
  1916. #endif
  1917.  
  1918.  
  1919. /************************************************************************/
  1920. /*                            initialization                            */
  1921. /************************************************************************/
  1922.  
  1923. void
  1924. syms_of_xselect (void)
  1925. {
  1926.   defsubr (&Sx_get_selection_internal);
  1927.   defsubr (&Sx_own_selection_internal);
  1928.   defsubr (&Sx_disown_selection_internal);
  1929.   defsubr (&Sx_selection_owner_p);
  1930.   defsubr (&Sx_selection_exists_p);
  1931.  
  1932. #ifdef CUT_BUFFER_SUPPORT
  1933.   defsubr (&Sx_get_cutbuffer_internal);
  1934.   defsubr (&Sx_store_cutbuffer_internal);
  1935.   defsubr (&Sx_rotate_cutbuffers_internal);
  1936. #endif
  1937.  
  1938.   /* Unfortunately, timeout handlers must be lisp functions. */
  1939.   defsymbol (&Qx_selection_reply_timeout_internal,
  1940.              "x-selection-reply-timeout-internal");
  1941.   defsubr (&Sx_selection_reply_timeout_internal);
  1942.  
  1943.   defsymbol (&QPRIMARY, "PRIMARY");
  1944.   defsymbol (&QSECONDARY, "SECONDARY");
  1945.   defsymbol (&QSTRING, "STRING");
  1946.   defsymbol (&QINTEGER, "INTEGER");
  1947.   defsymbol (&QCLIPBOARD, "CLIPBOARD");
  1948.   defsymbol (&QTIMESTAMP, "TIMESTAMP");
  1949.   defsymbol (&QTEXT, "TEXT");
  1950.   defsymbol (&QTIMESTAMP, "TIMESTAMP");
  1951.   defsymbol (&QDELETE, "DELETE");
  1952.   defsymbol (&QMULTIPLE, "MULTIPLE");
  1953.   defsymbol (&QINCR, "INCR");
  1954.   defsymbol (&QEMACS_TMP, "_EMACS_TMP_");
  1955.   defsymbol (&QTARGETS, "TARGETS");
  1956.   defsymbol (&QATOM, "ATOM");
  1957.   defsymbol (&QATOM_PAIR, "ATOM_PAIR");
  1958.   defsymbol (&QNULL, "NULL");
  1959.  
  1960. #ifdef EPOCH
  1961.   defsymbol (&QARC, "ARC");
  1962.   defsymbol (&QBITMAP, "BITMAP");
  1963.   defsymbol (&QCARDINAL, "CARDINAL");
  1964.   defsymbol (&QCURSOR, "CURSOR");
  1965.   defsymbol (&QDRAWABLE, "DRAWABLE");
  1966.   defsymbol (&QFONT, "FONT");
  1967.   defsymbol (&QINTEGER, "INTEGER");
  1968.   defsymbol (&QPIXMAP, "PIXMAP");
  1969.   defsymbol (&QPOINT, "POINT");
  1970.   defsymbol (&QRECTANGLE, "RECTANGLE");
  1971.   defsymbol (&QWINDOW, "WINDOW");
  1972.   defsymbol (&QWM_HINTS, "WM_HINTS");
  1973.   defsymbol (&QWM_SIZE_HINTS, "WM_SIZE_HINTS");
  1974. #endif /* EPOCH */
  1975.   
  1976. #ifdef CUT_BUFFER_SUPPORT
  1977.   defsymbol (&QCUT_BUFFER0, "CUT_BUFFER0");
  1978.   defsymbol (&QCUT_BUFFER1, "CUT_BUFFER1");
  1979.   defsymbol (&QCUT_BUFFER2, "CUT_BUFFER2");
  1980.   defsymbol (&QCUT_BUFFER3, "CUT_BUFFER3");
  1981.   defsymbol (&QCUT_BUFFER4, "CUT_BUFFER4");
  1982.   defsymbol (&QCUT_BUFFER5, "CUT_BUFFER5");
  1983.   defsymbol (&QCUT_BUFFER6, "CUT_BUFFER6");
  1984.   defsymbol (&QCUT_BUFFER7, "CUT_BUFFER7");
  1985. #endif
  1986. }
  1987.  
  1988. void
  1989. vars_of_xselect (void)
  1990. {
  1991. #ifdef CUT_BUFFER_SUPPORT
  1992.   cut_buffers_initialized = 0;
  1993. #endif
  1994.  
  1995.   reading_selection_reply = 0;
  1996.   reading_which_selection = 0;
  1997.   selection_reply_timed_out = 0;
  1998.   for_whom_the_bell_tolls = 0;
  1999.   prop_location_tick = 0;
  2000.  
  2001.   Vselection_alist = Qnil;
  2002.   staticpro (&Vselection_alist);
  2003.  
  2004.   DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist,
  2005.   "An alist associating selection-types (such as STRING and TIMESTAMP) with\n\
  2006. functions.  These functions will be called with three args: the name of the\n\
  2007. selection (typically PRIMARY, SECONDARY, or CLIPBOARD); a desired type to\n\
  2008. which the selection should be converted; and the local selection value\n(\
  2009. whatever had been passed to `x-own-selection').  These functions should\n\
  2010. return the value to send to the X server (typically a string).  A return\n\
  2011. value of nil means that the conversion could not be done.  A return value\n\
  2012. which is the symbol NULL means that a side-effect was executed, and there\n\
  2013. is no meaningful return value.");
  2014.   Vselection_converter_alist = Qnil;
  2015.  
  2016.   DEFVAR_LISP ("x-lost-selection-hooks", &Vx_lost_selection_hooks,
  2017.   "A function or functions to be called after the X server has notified us\n\
  2018. that we have lost the selection.  The function(s) will be called with one\n\
  2019. argument, a symbol naming the selection (typically PRIMARY, SECONDARY, or\n\
  2020. CLIPBOARD).");
  2021.   Vx_lost_selection_hooks = Qunbound;
  2022.  
  2023.   DEFVAR_LISP ("x-sent-selection-hooks", &Vx_sent_selection_hooks,
  2024.   "A function or functions to be called after we have responded to some\n\
  2025. other client's request for the value of a selection that we own.  The\n\
  2026. function(s) will be called with four arguments:\n\
  2027.   - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD);\n\
  2028.   - the name of the selection-type which we were requested to convert the\n\
  2029.     selection into before sending (for example, STRING or LENGTH);\n\
  2030.   - and whether we successfully transmitted the selection.\n\
  2031. We might have failed (and declined the request) for any number of reasons,\n\
  2032. including being asked for a selection that we no longer own, or being asked\n\
  2033. to convert into a type that we don't know about or that is inappropriate.\n\
  2034. This hook doesn't let you change the behavior of emacs's selection replies,\n\
  2035. it merely informs you that they have happened.");
  2036.   Vx_sent_selection_hooks = Qunbound;
  2037.  
  2038.   DEFVAR_INT ("x-selection-timeout", &x_selection_timeout,
  2039.    "If the selection owner doesn't reply in this many seconds, we give up.\n\
  2040. A value of 0 means wait as long as necessary.  This is initialized from the\n\
  2041. \"*selectionTimeout\" resource (which is expressed in milliseconds).");
  2042.   x_selection_timeout = 0;
  2043. }
  2044.  
  2045. void
  2046. Xatoms_of_xselect (struct device *d)
  2047. {
  2048. #define ATOM(x) XInternAtom (DEVICE_X_DISPLAY (d), (x), False)
  2049.  
  2050.   /* Non-predefined atoms that we might end up using a lot */
  2051.   DEVICE_XATOM_CLIPBOARD (d) =    ATOM ("CLIPBOARD");
  2052.   DEVICE_XATOM_TIMESTAMP (d) =    ATOM ("TIMESTAMP");
  2053.   DEVICE_XATOM_TEXT (d) =    ATOM ("TEXT");
  2054.   DEVICE_XATOM_DELETE (d) =    ATOM ("DELETE");
  2055.   DEVICE_XATOM_MULTIPLE (d) =    ATOM ("MULTIPLE");
  2056.   DEVICE_XATOM_INCR (d) =    ATOM ("INCR");
  2057.   DEVICE_XATOM_EMACS_TMP (d) =    ATOM ("_EMACS_TMP_");
  2058.   DEVICE_XATOM_TARGETS (d) =    ATOM ("TARGETS");
  2059.   DEVICE_XATOM_NULL (d) =    ATOM ("NULL");
  2060.   DEVICE_XATOM_ATOM_PAIR (d) =    ATOM ("ATOM_PAIR");
  2061. }
  2062.